****************************************************************************** * GENMENU - Menu code generator. * * Copyright (c) 1990 - 2001 Microsoft Corp. * 1 Microsoft Way * Redmond, WA 98052 * * Description: * This program generates menu code which was designed in the * Visual FoxPro 7.0 MENU BUILDER. * * Modification History: * December 13, 1990 JAC Program Created * * Modified for FoxPro 2.5 by WJK * Modified for Visual FoxPro 3.0 by DTA * Modified for Visual FoxPro 5.0-7.0 by RB * ****************************************************************************** * MS SourceSafe Keywords: * $Workfile: GENMENU.PRG $ * $Author: Dta $ * $Date: 3/19/95 1:04a $ * $Logfile: /Genmenu/GENMENU.PRG $ * $Modtime: 3/19/95 1:04a $ * $Revision: 8 $ * * NOTE: Revisions history kept at end of file. ****************************************************************************** ****************************************************************************** * * Declare Constants * ****************************************************************************** * Move constants above executable code [Rev: 3][BEG] #DEFINE c_DEBUG .T. && Add debug mode [Rev: 4][ADD] * #DEFINE c_esc CHR(27) #DEFINE c_null CHR(0) #DEFINE c_CRLF CHR(13) + CHR(10) && Carriage return + Line feed constant [Rev: 6][ADD] #DEFINE c_aliaslen 255 && Support long file names [Rev: 7][MOD] * * Possible values of Objtype field in SCX database. * #DEFINE c_menu 1 #DEFINE c_submenu 2 #DEFINE c_item 3 #DEFINE c_shortcut 4 #DEFINE c_sdimenu 5 * * Some of the values of Objcode field in SCX database. * #DEFINE c_global 1 #DEFINE c_proc 80 #DEFINE c_maxsnippets 25 #DEFINE c_maxpads 25 #DEFINE c_pjx20flds 33 #DEFINE c_pjxflds 28 && Changed from 31 [Rev: 2][MOD] #DEFINE c_mnxflds 23 #DEFINE c_20mnxflds 22 #DEFINE c_70mnxflds 25 #DEFINE c_space 40 && Used by Thermfname * * Developer Information * #DEFINE c_authorlen 45 #DEFINE c_complen 45 #DEFINE c_addrlen 45 #DEFINE c_citylen 20 #DEFINE c_statlen 5 #DEFINE c_ziplen 10 #DEFINE c_countrylen 40 * * Menu / pad location * #DEFINE c_replace 0 #DEFINE c_append 1 #DEFINE c_before 2 #DEFINE c_after 3 * #DEFINE c_pathsep "\" * * Add support for negotiate [Rev: 2][BEG] #DEFINE c_neg_flag "LOCATION" #DEFINE c_neg_none 0 #DEFINE c_neg_left 1 #DEFINE c_neg_middle 2 #DEFINE c_neg_right 3 * Add support for negotiate [Rev: 2][BEG] * * Add localization support [Rev: 2][BEG] #DEFINE c_hdr_author_LOC "Author's Name" #DEFINE c_hdr_company_LOC "Company Name" #DEFINE c_hdr_address_LOC "Address" #DEFINE c_hdr_city_LOC "City" #DEFINE c_hdr_state_LOC " " #DEFINE c_hdr_zip_LOC "Zip" #DEFINE c_hdr_ctry_LOC "Country" #DEFINE c_hdr_copyright_LOC Copyright (C) #DEFINE c_hdr_descript_LOC Description: #DEFINE c_hdr_string_LOC This PROGRAM was automatically generated BY GENMENU. #DEFINE c_shortcutdef_LOC "FoxShortcutMenu" * #DEFINE c_snip_setup_LOC " Setup Code" #DEFINE c_snip_cleanup_LOC " Cleanup Code & Procedures" #DEFINE c_snip_init_LOC " Initializing Code" #DEFINE c_snip_menu_LOC " Menu Definition" #DEFINE c_dlgface_mac_LOC "Geneva" #DEFINE c_dlgface_nonmac_LOC "MS Sans Serif" #DEFINE c_dlgstyle_mac_LOC "" #DEFINE c_dlgstyle_nonmac_LOC "" * * Genmenu error types * #DEFINE c_error_1 "Minor" #DEFINE c_error_2 "Serious" #DEFINE c_error_3 "Fatal" #DEFINE c_error_1Icon 64 && Error icons [Rev: 6][ADD] #DEFINE c_error_2Icon 48 && Error icons [Rev: 6][ADD] #DEFINE c_error_3Icon 16 && Error icons [Rev: 6][ADD] #DEFINE c_err_invnumparm_LOC "Invalid number of parameters passed to the generator." #DEFINE c_err_badgendate_LOC "Generator out of date." #DEFINE c_err_badrechead_LOC "Missing header record in " #DEFINE c_err_nocloseapp_LOC "Unable to Close the Application File." #DEFINE c_err_badmnxpre_LOC "Menu " #DEFINE c_err_badmnxpost_LOC " is invalid" #DEFINE c_err_nofileopen_LOC "Cannot open file " #DEFINE c_err_badnegoval_LOC "Invalid negotiate value in field " #DEFINE c_err_title_LOC "Genmenu Error" #DEFINE c_err_lineno_LOC "Line Number: " #DEFINE c_err_presskey_LOC "Press any key to cleanup and exit..." #DEFINE c_err_noopenerr_LOC ".ERR could not be opened..." #DEFINE c_err_toomanymemvars_LOC "Too many memvars - GENMENU will terminate..." && ERROR 22 [Rev: 4][ADD] #DEFINE c_err_nobangallowed_LOC "Menu file name cannot contain the character " + [" ! "] && ! in menu [Rev: 6][ADD] * #DEFINE c_msg_gencomplete_LOC "Generation Complete" #DEFINE c_msg_genmenudefs_LOC "Generating menu definitions..." #DEFINE c_msg_genpopdefs_LOC "Generating popup definitions..." #DEFINE c_msg_genprocs_LOC "Generating procedures..." #DEFINE c_msg_gensetup_LOC "Generating Menu Setup Code..." #DEFINE c_msg_gencleanup_LOC "Generating Menu Cleanup Code..." #DEFINE c_msg_genstopped_LOC "Generation process stopped." #DEFINE c_msg_genmenucode_LOC "Generating Menu Code..." * #DEFINE c_sdierrdisplay_loc "[This menu can only be called from a Top-Level form. "+; "Ensure that your form's ShowWindow property is set to 2. "+; "Read the header section of the menu's MPR file for more details.]" * #DEFINE c_ui_whereis_LOC WHERE is * Add localization support [Rev: 2][END] * #DEFINE c_key_padhotkey_LOC "ALT+" && Add support for intelligent Pad hotkeys. [Rev: 7][ADD] * Move constants above executable code [Rev: 3][END] ****************************************************************************** * * Main program * ****************************************************************************** PARAMETER m.projdbf, m.recno IF VAL(_VFP.Version) >= 7 LOCAL nLangOpt nLangOpt = _VFP.LanguageOptions _VFP.LanguageOptions = 0 ENDIF PRIVATE ALL * * Setup initial environment for GENMENU * IF SET("TALK") = "ON" SET TALK OFF m.talkstate = "ON" ELSE m.talkstate = "OFF" ENDIF m.coveragefile = SET("COVERAGE") m.oldtextmerge = SET("TEXTMERGE") SET COVERAGE TO m.escape = SET("ESCAPE") IF NOT c_DEBUG && Add debug mode [Rev: 4][ADD] SET ESCAPE OFF ENDIF m.trbetween = SET("TRBET") IF NOT c_DEBUG && Add debug mode [Rev: 4][ADD] SET TRBET OFF ENDIF m.comp = SET("COMPATIBLE") SET COMPATIBLE OFF mdevice = SET("DEVICE") SET DEVICE TO SCREEN m.alternate = SET("ALTE") SET ALTERNATE OFF ****************************************************************************** * * Declare Variables * ****************************************************************************** STORE "" TO m.cursor, m.consol, m.bell, m.onerror, m.fields, mfieldsto, ; m.exact, m.print, m.fixed, m.delimiters, m.mpoint, m.mcollate, m.mmacdesk, m.mcpdialog STORE 0 TO m.deci, m.memowidth * * Fonts for thermometer bar / dialogs * * Change fonts to memvars [Rev: 4][BEG] * Translate the filename into Mac native format IF _MAC m.g_dlgface = c_dlgface_mac_LOC m.g_dlgsize = 10.000 m.g_dlgstyle = c_dlgstyle_mac_LOC m.g_pathsep = ":" ELSE m.g_dlgface = c_dlgface_nonmac_LOC m.g_dlgsize = 8.000 m.g_dlgstyle = c_dlgstyle_nonmac_LOC m.g_pathsep = "\" ENDIF m.g_error = .F. m.g_errlog = "" m.g_homedir = "" m.g_location = 0 m.g_menucolor = 0 m.g_menumark = "" m.g_nohandle = .T. m.g_nsnippets = 0 m.g_outfile = "" m.g_padloca = "" m.g_projalias = "" m.g_projdbf = m.projdbf m.g_projpath = "" m.g_status = 0 m.g_snippcnt = 0 m.g_thermwidth = 0 m.g_workarea = 0 m.g_graphic = .F. m.g_20mnx = .F. m.g_shortcut = .F. m.g_inform = .F. m.g_shortcutname = "" m.g_prepopup = .F. m.g_imagepaths = .F. * * Add localization support [Rev: 2][BEG] m.g_devauthor = PADR( c_hdr_author_LOC ,45," ") m.g_devcompany = PADR( c_hdr_company_LOC ,45, " ") m.g_devaddress = PADR( c_hdr_address_LOC ,45," ") m.g_devcity = PADR( c_hdr_city_LOC ,20," ") m.g_devstate = c_hdr_state_LOC m.g_devzip = PADR( c_hdr_zip_LOC ,10," ") m.g_devctry = PADR( c_hdr_ctry_LOC ,40," ") * Add localization support [Rev: 2][END] * m.g_boxstrg = ['Ä','Ä','³','³','Ú','¿','À','Ù','Ä','Ä','³','³','Ú','¿','À','Ù'] * STORE "" TO m.g_corn1, m.g_corn2, m.g_corn3, m.g_corn4, m.g_corn5, ; m.g_corn6, m.g_verti2 STORE "*" TO m.g_horiz, m.g_verti1 * * * Array Declarations * * g_mnxfile [1] - Normalized path + name * g_mnxfile [2] - Basename * g_mnxfile [3] - Opened originally? * g_mnxfile [4] - Alias * DIMENSION g_mnxfile[4] g_mnxfile[1] = "" g_mnxfile[2] = "" g_mnxfile[3] = .F. g_mnxfile[4] = "" * * g_pads - names of generated menu pads * DIMENSION g_pads(c_maxpads) * * g_snippets [*,1] - generated snippet procedure name * g_snippets [*,2] - recno() * DIMENSION g_snippets (c_maxsnippets,2) g_snippets = "" DIMENSION g_aPops(1) g_aPops="" IF AT("WINDOWS", UPPER(VERSION())) <> 0 OR ; AT("MAC", UPPER(VERSION())) <> 0 m.g_graphic = .T. ELSE m.g_graphic = .F. ENDIF * * Main program * m.onerror = ON("ERROR") ON ERROR DO errorhandler WITH MESSAGE(), LINENO(), c_error_3 * IF PARAMETERS()=2 DO setup IF validparams() ON ESCAPE DO eschandler SET ESCAPE ON DO refreshprefs DO BUILD ENDIF DO cleanup ELSE DO errorhandler WITH c_err_invnumparm_LOC, LINENO(),c_error_3 && Localization support [Rev: 2][MOD] ENDIF ON ERROR &onerror * IF VAL(_VFP.Version) >= 7 _VFP.LanguageOptions = nLangOpt ENDIF RETURN m.g_status ****************************************************************************** * * Setup, Cleanup, Validparams, and Refreshprefs of Main Program * ****************************************************************************** * * STARTUP - Create program's environment. * * Description: * Save the user's environment so that we can set it back when * we are done, then issue various SET commands. The only state * we cannot conveniently save is SET TALK, because storing the * state involves an assignment statement, and assignments * generate unwanted output if TALK is set ON. * * Side Effects: * Creates a temporary file which is deleted in the Cleanup * procedure executed at the end of MENUGEN. * FUNCTION setup CLEAR PROGRAM CLEAR GETS m.g_workarea = SELECT() m.delimiters = SET('TEXTMERGE',1) SET TEXTMERGE DELIMITERS TO SET UDFPARMS TO VALUE m.mfieldsto = SET("FIELDS",1) m.fields = SET("FIELDS") SET FIELDS TO SET FIELDS OFF m.bell = SET("BELL") SET BELL OFF m.consol = SET("CONSOLE") SET CONSOLE OFF m.cursor = SET("CURSOR") SET CURSOR OFF m.deci = SET("DECIMALS") SET DECIMALS TO 0 mdevice = SET("DEVICE") SET DEVICE TO SCREEN m.memowidth = SET("MEMOWIDTH") SET MEMOWIDTH TO 256 m.exact = SET("EXACT") SET EXACT ON m.print = SET("PRINT") SET PRINT OFF m.fixed = SET("FIXED") SET FIXED ON mpoint = SET("POINT") SET POINT TO "." mcollate = SET("COLLATE") SET COLLATE TO "machine" mcpdialog = SET("CPDIALOG") SET CPDIALOG OFF #IF "MAC" $ UPPER(VERSION(1)) IF _MAC m.mmacdesk = SET("MACDESKTOP") SET MACDESKTOP ON ENDIF #ENDIF * * CLEANUP - restore environment to pre-execution state. * * Description: * Close all databases opened in the course of the execution of MENUGEN. * Restore the environment to the pre-execution of MENUGEN. Delete * the VIEW file since there is no further use for it. * * Side Effects: * Closes databases. * Deletes the temporary view file. * FUNCTION cleanup PRIVATE m.delilen, m.ldelimi, m.rdelimi IF EMPTY(m.g_projalias) RETURN ENDIF SELECT (m.g_projalias) USE IF NOT EMPTY(g_mnxfile[3]) IF USED(g_mnxfile[4]) SELECT (g_mnxfile[4]) USE ENDIF ENDIF SELECT (m.g_workarea) m.delilen = LEN(m.delimiters) m.ldelimi = SUBSTR(m.delimiters,1,; IIF(MOD(m.delilen,2)=0,m.delilen/2,CEILING(m.delilen/2))) m.rdelimi = SUBSTR(m.delimiters,; IIF(MOD(m.delilen,2)=0,m.delilen/2+1,CEILING(m.delilen/2)+1)) SET TEXTMERGE DELIMITERS TO m.ldelimi, m.rdelimi IF (LEN(mfieldsto) > 2048) SET FIELDS TO ELSE SET FIELDS TO &mfieldsto ENDIF IF m.fields = "ON" SET FIELDS ON ELSE SET FIELDS OFF ENDIF IF m.bell = "ON" SET BELL ON ENDIF IF m.cursor = "ON" SET CURSOR ON ELSE SET CURSOR OFF ENDIF IF m.consol = "ON" SET CONSOLE ON ENDIF IF m.escape = "ON" SET ESCAPE ON ELSE SET ESCAPE OFF ENDIF IF m.print = "ON" SET PRINT ON ENDIF IF m.exact = "OFF" SET EXACT OFF ENDIF IF m.fixed = "OFF" SET FIXED OFF ENDIF SET DECIMALS TO m.deci SET MEMOWIDTH TO m.memowidth SET DEVICE TO &mdevice IF m.trbetween = "ON" SET TRBET ON ENDIF IF m.comp = "ON" SET COMPATIBLE ON ENDIF IF m.talkstate = "ON" SET TALK ON ENDIF SET POINT TO "&mpoint" SET COLLATE TO "&mcollate" IF m.mcpdialog = "ON" SET CPDIALOG ON ENDIF IF m.alternate = "ON" SET ALTERNATE ON ENDIF SET MESSAGE TO #IF "MAC" $ UPPER(VERSION(1)) IF _MAC SET MACDESKTOP &mmacdesk ENDIF #ENDIF ON ERROR &onerror IF !EMPTY(m.coveragefile) SET COVERAGE TO (m.coveragefile) ADDITIVE ENDIF SET TEXTMERGE TO IF m.oldtextmerge = "ON" SET TEXTMERGE ON ENDIF * * VALIDPARAMS - Validate generator parameters. * * Description: * Attempt to open the project database. If error encountered then * on error routine takes over and issues 'CANCEL'. The output file * cannot be erased, name not known. * FUNCTION validparams SELECT 0 m.g_projalias = IIF(USED("projdbf"),"P"+; SUBSTR(LOWER(SYS(3)),2,8),"projdbf") USE (m.projdbf) ALIAS (m.g_projalias) AGAIN IF versnum() > "2.5" SET NOCPTRANS TO devinfo, symbols, OBJECT ENDIF m.g_errlog = stripext(m.projdbf) m.g_projpath = SUBSTR(m.projdbf,1,RAT("\",m.projdbf)) IF FCOUNT() <> c_pjxflds DO errorhandler WITH c_err_badgendate_LOC,LINENO(), c_error_2 && Localization support [Rev: 2][MOD] RETURN .F. ENDIF GOTO RECORD m.recno m.g_outfile = ALLTRIM(SUBSTR(outfile,1,AT(c_null,outfile)-1)) m.g_outfile = FULLPATH(m.g_outfile, m.g_projpath) IF _MAC AND RIGHT(m.g_outfile,1) = ":" m.g_outfile = m.g_outfile + justfname(SUBSTR(outfile,1,AT(c_null,outfile)-1)) ENDIF g_mnxfile[1] = FULLPATH(ALLTRIM(name), m.g_projpath) IF _MAC AND RIGHT(g_mnxfile[1],1) = ":" g_mnxfile[1] = g_mnxfile[1] + justfname(name) ENDIF g_mnxfile[2] = basename(g_mnxfile[1]) * No ! in menu name [Rev: 6][BEG] IF "!" $ g_mnxfile[2] DO errorhandler WITH c_err_nobangallowed_LOC, LINENO(), c_error_3 ENDIF * No ! in menu name [Rev: 6][END] * * REFRESHPREFS - Refresh comment style and developer preferences. * * Description: * Get the newest preferences for documentation style and developer * data from the project database. * FUNCTION refreshprefs PRIVATE m.start, m.savrecno m.savrecno = RECNO() LOCATE FOR TYPE = "H" IF NOT FOUND () DO errorhandler WITH c_err_badrechead_LOC + m.g_projdbf,; LINENO(), c_error_2 && Localization support [Rev: 2][MOD] GOTO RECORD m.savrecno RETURN ENDIF m.g_homedir = ALLTRIM(SUBSTR(homedir,1,AT(c_null,homedir)-1)) IF (RIGHT(m.g_homedir, 1) == "\") m.g_homedir = m.g_homedir + "\" ENDIF m.start = 1 m.g_devauthor = subdevinfo(m.start,c_authorlen,m.g_devauthor) m.start = m.start + c_authorlen + 1 m.g_devcompany = subdevinfo(m.start,c_complen,m.g_devcompany) m.start = m.start + c_complen + 1 m.g_devaddress = subdevinfo(m.start,c_addrlen,m.g_devaddress) m.start = m.start + c_addrlen + 1 m.g_devcity = subdevinfo(m.start,c_citylen,m.g_devcity) m.start = m.start + c_citylen + 1 m.g_devstate = subdevinfo(m.start,c_statlen,m.g_devstate) m.start = m.start + c_statlen + 1 m.g_devzip = subdevinfo(m.start,c_ziplen,m.g_devzip) m.start = m.start + c_ziplen + 1 m.g_devctry = subdevinfo(m.start,c_countrylen,m.g_devctry) IF cmntstyle = 0 m.g_corn1 = chr(214) m.g_corn2 = chr(183) m.g_corn3 = chr(211) m.g_corn4 = chr(189) m.g_corn5 = chr(199) m.g_corn6 = chr(182) m.g_horiz = chr(196) m.g_verti1 = chr(186) m.g_verti2 = chr(186) ENDIF GOTO RECORD m.savrecno * * SUBDEVINFO - Substring the DEVINFO memo filed. * FUNCTION subdevinfo PARAMETER m.start, m.stop, m.default PRIVATE m.string m.string = SUBSTR(devinfo, m.start, m.stop+1) m.string = SUBSTR(m.string, 1, AT(c_null,m.string)-1) RETURN IIF(EMPTY(m.string), m.default, m.string) ****************************************************************************** * * Menu Code Generator's Main Module. * ****************************************************************************** * * BUILD - Generate code for a menu. * * Description: * Call BUILDENABLE to open .MNX database specified by the user. * If the above is successfully accomplished, then proceed to generate * the menu code. After the menu code is generated, call BUILDDISABLE * to disable code generation between SET TEXTMERGE ON and * SET TEXTMERGE OFF. * FUNCTION BUILD IF NOT buildenable() RETURN ENDIF DO acttherm WITH c_msg_genmenucode_LOC && Localization support [Rev: 2][MOD] DO updtherm WITH 10 DO getmenutype DO header DO gensetupcleanup WITH "setup" DO definemenu DO definepopups DO updtherm WITH 75 DO globaldefaults DO updtherm WITH 95 DO gensetupcleanup WITH "cleanup" DO genprocedures IF m.g_graphic SET MESSAGE TO c_msg_gencomplete_LOC && Localization support [Rev: 2][MOD] ENDIF DO builddisable DO updtherm WITH 100 DO deactthermo * * BUILDENABLE - Enable code generation. * * Description: * Call opendb to open .MNX database. * Call openfile to open file to hold the generated program. * If error(s) encountered in opendb or openfile then don't do * anything and exit, otherwise enable code generation with the * SET TEXTMERGE ON command. * * Returns: * .T. on success; .F. on failure * FUNCTION buildenable PRIVATE m.stat, m.stat2 m.stat = opendb(g_mnxfile[1]) AND openfile() IF m.stat SET TEXTMERGE ON ENDIF RETURN m.stat * * BUILDDISABLE - Disable code generation. * * Description: * Issue the command SET TEXTMERGE OFF. * Close the generated menu code output file. * If anything goes wrong display appropriate message to the user. * FUNCTION builddisable SET ESCAPE OFF ON ESCAPE SET TEXTMERGE OFF IF NOT FCLOSE(_TEXT) DO errorhandler WITH c_err_nocloseapp_LOC, LINENO(), c_error_2 && Localization support [Rev: 2][MOD] ENDIF * * OPENDB - Prepare database for processing. * * Description: * Attempt to USE a database. If attempt fails and error is reported * call ERRORHANDLER routine to display a friendly message. Return * with a status of .F.. If attempt succeeds, return with status of .T. * * Returns: * .T. on success; .F. on failure * FUNCTION opendb PARAMETER m.dbname PRIVATE m.dbalias ON ERROR DO errorhandler WITH MESSAGE(), LINENO(), c_error_2 m.dbalias = LEFT(basename(m.dbname),c_aliaslen) IF USED (m.dbalias) SELECT (m.dbalias) IF RAT(".MNX",DBF())<>0 g_mnxfile[3] = .F. g_mnxfile[4] = m.dbalias ELSE g_mnxfile[4] = "M"+SUBSTR(LOWER(SYS(3)),2,8) SELECT 0 USE (m.dbname) AGAIN ALIAS (g_mnxfile[4]) g_mnxfile[3] = .T. ENDIF ELSE IF illegalname(m.dbalias) g_mnxfile[4] = "M"+SUBSTR(LOWER(SYS(3)),2,8) ELSE g_mnxfile[4] = m.dbalias ENDIF SELECT 0 USE (m.dbname) AGAIN ALIAS (g_mnxfile[4]) g_mnxfile[3] = .T. ENDIF IF FCOUNT() < c_mnxflds IF FCOUNT() = c_20mnxflds m.g_20mnx = .T. ELSE DO errorhandler WITH c_err_badmnxpre_LOC + m.dbalias + c_err_badmnxpost_LOC, ; LINENO(), c_error_2 && Localization support [Rev: 2][MOD] RETURN .F. ENDIF ELSE m.g_20mnx = .F. ENDIF ON ERROR DO errorhandler WITH MESSAGE(), LINENO(), c_error_3 IF m.g_error = .T. RETURN .F. ENDIF * * ILLEGALNAME - Check if default alias will be used when this * database is USEd. (i.e., 1st letter is not A-Z, * a-z or '_', or any one of ramaining letters is not * alphanumeric.) * FUNCTION illegalname PARAMETER m.menuname PRIVATE m.start, m.aschar, m.length m.length = LEN(m.menuname) m.start = 0 IF m.length = 1 * * If length 1, then check if default alias can be used, * i.e., name is different than A-J and a-j. * m.aschar = ASC(m.menuname) IF (m.aschar >= 65 AND m.aschar <= 74) OR ; (m.aschar >= 97 AND m.aschar <= 106) RETURN .T. ENDIF ENDIF DO WHILE m.start < m.length m.start = m.start + 1 m.aschar = ASC(SUBSTR(m.menuname, m.start, 1)) IF m.start<>1 AND (m.aschar >= 48 AND m.aschar <= 57) LOOP ENDIF IF NOT ((m.aschar >= 65 AND m.aschar <= 90) OR ; (m.aschar >= 97 AND m.aschar <= 122) OR m.aschar = 95) RETURN .T. ENDIF ENDDO RETURN .F. * * OPENFILE - Create and open the application output file. * * Description: * Create a file that will hold the generated menu code. * Open the newly created file. If error(s) encountered * at any time issue an error message and return .F. * * Returns: * .T. on success; .F. on failure * FUNCTION openfile PRIVATE m.msg _TEXT = FCREATE(m.g_outfile) IF (_TEXT = -1) m.msg = c_err_nofileopen_LOC + m.g_outfile && Localization support [Rev: 2][MOD] DO errorhandler WITH m.msg, LINENO(), c_error_3 m.g_nohandle = .T. RETURN .F. ENDIF m.g_nohandle = .F. * * DEFINEMENU - Define main menu and its pads. * * Description: * Issue DEFINE MENU ... command. * Call a procedure to define all menu pads. * Call a procedure to generate ON PAD statements when appropriate. * FUNCTION definemenu IF m.g_graphic SET MESSAGE TO c_msg_genmenudefs_LOC && Localization support [Rev: 2][MOD] ENDIF DO commentblock WITH "menu" SELECT (g_mnxfile[4]) IF m.g_shortcut RETURN && skip if shortcut menu ENDIF LOCATE FOR objtype = c_menu IF EOF() * using Top-Level menu instead LOCATE FOR objtype = c_sdimenu ENDIF m.g_location = location m.g_padloca = ALLTRIM(name) LOCATE FOR objtype = c_submenu AND objcode = c_global m.g_menucolor = SCHEME m.g_menumark = MARK DO CASE CASE m.g_inform AND m.g_location = c_replace \DEFINE MENU (m.cMenuName) IN (m.oFormRef.Name) BAR CASE m.g_inform \LOCAL lHasNewMenu \lHasNewMenu = (TYPE("CNTPAD(m.cMenuName)") # "N") \IF m.lHasNewMenu \ DEFINE MENU (m.cMenuName) IN (m.oFormRef.Name) BAR \ENDIF CASE (m.g_location >= 4 OR m.g_location=c_replace) * Special BiDi handling IF (m.g_location >= 4) m.g_location = m.g_location - 4 IF sys(4015)=1 \SET SYSMENU TO RTLJUSTIFY ENDIF ENDIF IF m.g_location = c_replace \SET SYSMENU TO \SET SYSMENU AUTOMATIC ENDIF ENDCASE \ DO updtherm WITH 25 DO defmenupads DO updtherm WITH 35 DO defonpad \ DO updtherm WITH 45 * * DEFMENUPADS - Define all pads for the menu bar. * * Description: * Scan the menu database for all objects of the type item which * have the levelname=_MSYSMENU. * For each such item, generate a statement DEFINE PAD... where * the name of the pad is the contents of NAME field or (if Name * field is empty) an automatically generated name. * Call procedures addkey, addskipfor, and mark to generate * KEY, SKIPFOR, or MARK clauses when appropriate. * FUNCTION defmenupads PRIVATE m.padname, m.prompt LOCAL lcNegotiate && Add support for OLE2 Negotiate [Rev: 2][MOD] LOCAL lcNegContainer && Add support for ActiveDoc Negotiate LOCAL lcNegObject && Add support for ActiveDoc Negotiate SCAN FOR objtype=c_item AND UPPER(levelname)="_MSYSMENU" IF NOT EMPTY(ALLTRIM(name)) g_pads[VAL(Itemnum)] = name ELSE g_pads[VAL(Itemnum)] = LOWER(SYS(2015)) ENDIF DO CASE CASE m.g_inform \DEFINE PAD <> OF (m.cMenuName) OTHERWISE \DEFINE PAD <> OF _MSYSMENU ENDCASE IF MOD(VAL(itemnum),25)=0 DIMENSION g_pads[VAL(Itemnum)+25] ENDIF m.prompt = SUBSTR(PROMPT,1,LEN(PROMPT)) \\ PROMPT "<>" \\ COLOR SCHEME <> IF m.g_menumark<>c_null AND m.g_menumark<>"" \\ ; \ MARK "<>" ENDIF DO CASE CASE m.g_location = c_before \\ ; \ BEFORE <> CASE m.g_location = c_after \\ ; \ AFTER IF VAL(itemnum) = 1 \\ <> ELSE \\ <> ENDIF ENDCASE * Add support for OLE2 Negotiate [Rev: 2][BEG] * c_neg_flag is a quote delimited constant for the field that must be evaluated * for a legal negotiate value. lcNegotiate = EVAL( c_neg_flag ) IF NOT EMPTY( m.lcNegotiate ) m.lcNegContainer = BITAND(m.lcNegotiate, 0x000F) m.lcNegObject = BITRSHIFT(BITAND(m.lcNegotiate, 0x00F0), 4) \\ ; \ NEGOTIATE DO CASE CASE m.lcNegContainer = c_neg_none \\ NONE, CASE m.lcNegContainer = c_neg_left \\ LEFT, CASE m.lcNegContainer = c_neg_middle \\ MIDDLE, CASE m.lcNegContainer = c_neg_right \\ RIGHT, OTHERWISE DO errorhandler WITH c_err_badnegoval_LOC + c_neg_flag ,; LINENO(),c_error_2 && Localization support [Rev: 2][MOD] ENDCASE DO CASE CASE m.lcNegObject = c_neg_none \\ NONE CASE m.lcNegObject = c_neg_left \\ LEFT CASE m.lcNegObject = c_neg_middle \\ MIDDLE CASE m.lcNegObject = c_neg_right \\ RIGHT OTHERWISE DO errorhandler WITH c_err_badnegoval_LOC + c_neg_flag ,; LINENO(),c_error_2 && Localization support [Rev: 2][MOD] ENDCASE ENDIF RELEASE m.negotiate * Add support for OLE2 Negotiate [Rev: 2][END] DO addkey DO addskipfor DO addmessage ENDSCAN * * DEFONPAD - Generate ON PAD... statements. * * Description: * Generate ON PAD statements for each pad off of the main menu which * has a submenu associated with it. * For pads which have no submenus, but there is a command associated * with them, issue ON SELECTION PAD... statements. If the code * associated with a pad is a snippet, then issue a call to the * generated procedure and place the snippet code in it. * FUNCTION defonpad PRIVATE m.padname SCAN FOR objtype=c_item AND UPPER(levelname)="_MSYSMENU" IF NOT EMPTY(ALLTRIM(name)) m.padname = name ELSE m.padname = g_pads[VAL(Itemnum)] ENDIF m.therec = RECNO() SKIP IF objtype=c_submenu AND numitems<>0 IF m.g_inform \ON PAD <> OF (m.cMenuName) \\ ACTIVATE POPUP (a_menupops[<>]) ELSE \ON PAD <> OF _MSYSMENU \\ ACTIVATE POPUP <> ENDIF GOTO m.therec ELSE GOTO m.therec DO onselection WITH "pad", m.padname, '_MSYSMENU' ENDIF ENDSCAN * * DEFINEPOPUPS - Define popups and their bars. * * Description: * Scan the Menu database to find all objecttypes = submenu. * They all correspond to popups. For each such object found, issue * command DEFINE POPUP.... Add MARK, KEY, and SKIP FOR clauses * if appropriate by calling procedures to handle these tasks. Call * procedure Defbars to define all bars of each popup. * FUNCTION definepopups PRIVATE m.savrecno, m.popname, m.sch, m.firstpop,m.newpopname m.firstpop = .T. IF m.g_graphic SET MESSAGE TO c_msg_genpopdefs_LOC && Localization support [Rev: 2][MOD] ENDIF SCAN FOR objtype=c_submenu AND UPPER(levelname)<>"_MSYSMENU" ; AND numitems <> 0 m.savrecno = RECNO() m.popname = ALLTRIM(LOWER(levelname)) m.newpopname = m.popname m.sch = SCHEME DO CASE CASE m.g_shortcut AND m.firstpop * safeguard against system popups used for top popup name IF LOWER(LEFT(Name,2))="_m" * Use default name STORE c_shortcutdef_loc TO m.newpopname,m.g_shortcutname ELSE m.g_shortcutname = LOWER(Name) ENDIF m.firstpop = .F. \DEFINE POPUP <> SHORTCUT RELATIVE FROM MROW(),MCOL() CASE m.g_shortcut \DEFINE POPUP <> SHORTCUT RELATIVE CASE m.g_inform \DEFINE POPUP (a_menupops[<>]) MARGIN RELATIVE SHADOW \\ COLOR SCHEME <> OTHERWISE \DEFINE POPUP <> MARGIN RELATIVE SHADOW \\ COLOR SCHEME <> ENDCASE DO addmark DO addkey DO defbars WITH m.popname, numitems, m.newpopname DO defonbar WITH m.popname, m.newpopname \ GOTO RECORD m.savrecno ENDSCAN * * DEFBARS - Define bars for each popup. * * Description: * Scan the menu database for all objects of the type item whose * name equals to the current popup name. * For each such item, generate a statement DEFINE BAR.... * Call procedures addkey, addskipfor, and addmark to generate * KEY, SKIPFOR, or MARK clauses when appropriate. * FUNCTION defbars PARAMETER m.popname, m.howmany, m.newname IF EMPTY(m.newname) m.newname = m.popname ENDIF PRIVATE m.itemno, m.prompt,m.name, m.cPopExpr SCAN FOR objtype=c_item AND LOWER(levelname)=m.popname IF INLIST(LOWER(ALLTRIM(name)),"_mwz_setup","_mtl_spell","_mti_runactivedoc") LOOP ENDIF m.itemno = ALLTRIM(itemnum) m.cPopExpr = IIF(m.g_inform, "(a_menupops["+ALLTRIM(STR(ASCAN(g_apops,LOWER(m.newname))))+"])", LOWER(m.newname)) IF NOT EMPTY(ALLTRIM(name)) m.name = name \DEFINE BAR <> OF <> ELSE \DEFINE BAR <> OF <> ENDIF m.prompt = SUBSTR(PROMPT, 1,LEN(PROMPT)) \\ PROMPT "<>" DO addmark DO addkey DO addskipfor DO addpicture DO addmessage IF VAL(m.itemno)=m.howmany RETURN ENDIF ENDSCAN * * DEFONBAR - Generate ON BAR... statements. * * Description: * Generate ON BAR statements for each popup. * For bars which have no submenus, but there is a command associated * with them, issue ON SELECTION BAR... statements. If a snippet is * associated with the code then generate a call statement to the * generated procedure containing the snippet code. * FUNCTION defonbar PARAMETER m.popname,m.newname PRIVATE m.itemno, m.cPopExpr , m.cPopExpr2 IF EMPTY(m.newname) m.newname = m.popname ENDIF SCAN FOR objtype=c_item AND LOWER(levelname)=m.popname IF EMPTY(ALLTRIM(name)) m.itemno = ALLTRIM(itemnum) ELSE m.itemno = name ENDIF SKIP m.cPopExpr = IIF(m.g_inform, "(a_menupops["+ALLTRIM(STR(ASCAN(g_apops,LOWER(m.newname))))+"])", LOWER(m.newname)) m.cPopExpr2 = IIF(m.g_inform, "(a_menupops["+ALLTRIM(STR(ASCAN(g_apops,LOWER(name))))+"])", LOWER(name)) IF objtype=c_submenu AND numitems<>0 \ON BAR <> OF <> \\ ACTIVATE POPUP <> SKIP -1 ELSE SKIP -1 DO onselection WITH "BAR", m.itemno, m.newname ENDIF ENDSCAN * * GLOBALDEFAULTS - Generate global default statements * * Description: * Search the menu database for information needed to generate any of * the following commands: * ON SELECTION MENU DO * ON SELECTION POPUP ALL DO * ON SELECTION POPUP DO * It is possible that none of the above mentioned statements will be * generated. It is also possible that the action is a snippet of * code and a call to the generated procedure containing the snippet * will be generated. * * First try to generate ON SELECTION MENU... * Then try to generate ON POPUP ALL... * Lastly, try to generate ON SELECTION POPUP... * FUNCTION globaldefaults LOCATE FOR objtype = c_menu LOCAL m.cPopExpr m.mrk = MARK IF FOUND() AND MARK <> "" IF MARK = c_null \SET MARK OF MENU _MSYSMENU TO " " ELSE \SET MARK OF MENU _MSYSMENU TO "<>" ENDIF ENDIF IF FOUND() AND NOT EMPTY(PROCEDURE) \ON SELECTION MENU _MSYSMENU DO genproccall ENDIF LOCATE FOR objtype = c_submenu AND objcode = c_global IF FOUND() AND NOT EMPTY(PROCEDURE) \ON SELECTION POPUP ALL DO genproccall ENDIF SCAN FOR (objtype=c_submenu AND UPPER(levelname)<>"_MSYSMENU"; AND NOT EMPTY(PROCEDURE)) m.cPopExpr = IIF(m.g_inform, "(a_menupops["+ALLTRIM(STR(ASCAN(g_apops,ALLTRIM(LOWER(Levelname)))))+"])", ALLTRIM(LOWER(Levelname))) \ON SELECTION POPUP <> DO genproccall ENDSCAN ****************************************************************************** * * Subroutines for processing menu clause options. * ****************************************************************************** * * ADDMARK - Generate a MARK clause whenever appropriate. * * Description: * Add a MARK clause to the current PAD or BAR definition. * If a field named Mark is not empty, then add the continuation * character, ";", to the previous line, and then add the MARK... clause. * FUNCTION addmark IF MARK<>c_null AND MARK<>"" \\ ; \ MARK "<>" ENDIF * * ADDKEY - Generate KEY... clause whenever appropriate. * * Description: * Add a KEY clause to the current PAD or BAR definition. * If a field named Keyname is not empty, then add the continuation * character, ";", to the previous line, and then add the KEY... clause. * FUNCTION addkey * Add support for intelligent Pad hotkeys. [Rev: 7][BEG] * NOTE: For consistency, Pads no longer respect keyname and * keylabel, they use the letter following "\<" or the * first letter of the prompt of none is defined. LOCAL cKeyname, cKeylabel, nPosition IF objtype=c_item AND ; UPPER(levelname)="_MSYSMENU" AND ; EMPTY(keyname) nPosition = AT_C("\<",prompt) IF m.nPosition > 0 AND NOT EMPTY(SUBSTRC(prompt,m.nPosition+2,1)) STORE c_key_padhotkey_LOC + UPPER(SUBSTRC(prompt,m.nPosition+2,1)) TO m.cKeyname ELSE IF !IsLeadByte(prompt) STORE c_key_padhotkey_LOC + UPPER(LEFT(prompt,1)) TO m.cKeyname ELSE STORE "" to m.cKeyname ENDIF ENDIF cKeylabel = "" ELSE cKeyname = keyname cKeylabel = keylabel ENDIF IF NOT EMPTY(m.cKeyname) \\ ; \ KEY <>, "<>" ENDIF * Add support for intelligent Pad hotkeys. [Rev: 7][END] * * ADDPICTURE - Generate PICTURE... clause whenever appropriate. * * Description: * Adds a PICTURE/PICTRES clause for the DEFINE BAR command * FUNCTION addpicture LOCAL lcPictName,lcPictType, lcFileName IF FCOUNT() < c_70mnxflds RETURN ENDIF lcPictName = ALLTRIM(resname) lcPictType = sysres IF m.lcPictType#1 AND !EMPTY(m.lcPictName) AND g_imagepaths m.lcFileName = FULLPATH(m.lcPictName,g_mnxfile[1]) IF FILE(m.lcFileName) m.lcPictName = m.lcFileName ENDIF ENDIF IF NOT EMPTY(m.lcPictName) \\ ; IF m.lcPictType=1 \ PICTRES <> ELSE \ PICTURE "<>" ENDIF ENDIF * * ADDSKIPFOR - Generate SKIP FOR... clause whenever appropriate. * * Description: * Add a ADDSKIPFOR clause to the current PAD or BAR definition. * If a field named Addskipfor is not empty, then add the continuation * character, ";", to the previous line, and then add the SKIP FOR... * clause. * * VFP7 - we now ignore if SKIP .F. and pass remaining contents * FUNCTION addskipfor PRIVATE m.skip LOCAL lcWord1, lcWord2 m.skip = skipfor IF NOT EMPTY(skipfor) lcWord1 = UPPER(GETWORDNUM(ALLTRIM(m.skip),1)) lcWord2 = UPPER(GETWORDNUM(ALLTRIM(m.skip),2)) IF lcWord1==".F." AND !EMPTY(lcWord2) AND !INLIST(lcWord2,"AND",".AND.","OR",".OR.") m.skip = ALLTRIM(STREXTRACT(m.skip,".F.","",1,1)) IF !EMPTY(m.skip) \\ ; \ <> ENDIF ELSE \\ ; \ SKIP FOR <> ENDIF ENDIF * * ADDMESSAGE - Generate MESSAGE clause whenever appropriate. * * Description: * Add a MESSAGE clause to the current PAD or BAR definition. * If a field named MESSAGE is not empty and it is not a 2.0 menu, * then add the continuation character, ";", to the previous line, * and then add the MESSAGE clause. * FUNCTION addmessage IF !m.g_20mnx AND NOT EMPTY(MESSAGE) \\ ; \ MESSAGE <> ENDIF * * HEADER - Generate generated program's header. * * Description: * As a part of the automatically generated program's header generate * program name, name of the author of the program, copyright notice, * company name and address, and the word 'Description:' which will be * followed with a short description of the generated code. * FUNCTION HEADER \\* <><><> \* <><><> \* <> <> \\<> \\ <> <> \* <><><> \* <><><> \* <><><> \* <> <> \\<><> \* <><><> \* <> *- Localization support [Rev: 2][MOD] \\ c_hdr_copyright_LOC <> IF LEN(ALLTRIM(m.g_devcompany)) <= 36 \\ <> \\<> \\<> ELSE \\ <><> \* <> <> \\<><> ENDIF \* <> <> \\<><> \* <> <>, <> \\ <> \\<> \\<> IF !INLIST(ALLTRIM(UPPER(m.g_devctry)),"USA","COUNTRY") AND !EMPTY(m.g_devctry) \* <> <> \\<> \\<> ENDIF \* <><><> *- Localization support [Rev: 2][MOD] \* <> c_hdr_descript_LOC \\ <> \* <> *- Localization support [Rev: 2][MOD] \\ c_hdr_string_LOC \\ <> \* <><><> \* <><><> \ * * GENFUNCHEADER - Generate Comment for Function/Procedure. * FUNCTION genfuncheader PARAMETER m.procname PRIVATE m.place, m.prompt m.g_snippcnt = m.g_snippcnt + 1 DO CASE CASE objtype = c_menu m.place = "ON SELECTION MENU _MSYSMENU" CASE objtype = c_submenu AND objcode = c_global m.place = "ON SELECTION POPUP ALL" CASE objtype = c_submenu AND objcode <> c_global m.place = "ON SELECTION POPUP "+LOWER(ALLTRIM(name)) CASE objtype = c_item AND UPPER(levelname) = "_MSYSMENU" m.place = "ON SELECTION PAD " CASE objtype = c_item AND UPPER(levelname) <> "_MSYSMENU" m.place = "ON SELECTION BAR "+ALLTRIM(itemnum)+; +" OF POPUP "+LOWER(ALLTRIM(levelname)) OTHERWISE m.place = "" ENDCASE \ \* <><><> \* <><><> \* <> <> <> \\<><> \* <><><> \* <> Procedure Origin: \\<><> \* <><><> \* <> From Menu: \\ <> \\, Record: <> \\<> \\<> \* <> Called By: <> \\<><> IF NOT EMPTY(PROMPT) m.prompt = removemeta() \* <> Prompt: <> \\<><> ENDIF \* <> Snippet: \\ <> \\<><> \* <><><> \* <><><> \* * * REMOVEMETA - Remove meta characters for documentation. * FUNCTION removemeta PRIVATE m.prompt, m.hotkey m.prompt = PROMPT m.hotkey = AT("\<",m.prompt) IF m.hotkey <> 0 m.prompt = STUFF(m.prompt,m.hotkey,2,"") ENDIF m.disabl = AT("\",m.prompt) IF m.disabl <> 0 m.prompt = STUFF(m.prompt,m.disabl,1,"") ENDIF RETURN m.prompt * * COMMENTBLOCK - Generate a comment block. * FUNCTION commentblock PARAMETER m.snippet \ \* <><><> \* <><><> DO CASE CASE m.snippet == "setup" \* <> *- Localization support [Rev: 2][MOD] \\ <> CASE m.snippet == "cleanup" \* <> *- Localization support [Rev: 2][MOD] \\ <> CASE m.snippet == "init" \* <> *- Localization support [Rev: 2][MOD] \\ <> CASE m.snippet == "menu" \* <> *- Localization support [Rev: 2][MOD] \\ <> ENDCASE \\<> \* <><><> \* <><><> \* \ * * ONSELECTION - Generate ON SELECTION... statements for menu items. * * Description: * For pads and bars which have no submenu associated with them but * instead have a non-empty Command field in the database, issue * the ON SELECTION statements. If a snippet is associated * with a pad then issue a call statement to the generated procedure * containing the snippet. Generated snippet procedure will be * appended to the end of the output file. * FUNCTION onselection PARAMETER m.which, m.name, m.ofname PRIVATE m.trimname, m.basename, m.commd, m.cPopExpr IF EMPTY(PROCEDURE) AND EMPTY(COMMAND) RETURN ENDIF DO CASE CASE m.which == "pad" \ON SELECTION PAD <> CASE m.which == "BAR" \ON SELECTION <> ENDCASE IF m.g_inform AND !m.g_shortcut AND m.which#"BAR" \\ OF (m.cMenuName) ELSE m.cPopExpr = IIF(m.g_inform, "(a_menupops["+ALLTRIM(STR(ASCAN(g_apops,m.ofname)))+"])",m.ofname) \\ OF <> ENDIF IF objcode = c_proc DO gensnippname m.trimname = SYS(2014,UPPER(m.g_outfile),UPPER(m.g_homedir)) m.trimname = stripext(m.trimname) m.basename = basename(m.trimname) \\ ; \ DO <> ; \ IN LOCFILE("<>" \\ ,"MPX;MPR|FXP;PRG" \\ ," *- Localization support [Rev: 2][MOD] \\c_ui_whereis_LOC \\ <>?") ELSE m.commd = COMMAND \\ <> ENDIF * * GENSNIPPNAME - Generate a unique name for snippet procedure. * * Description: * Lookup the #NAME name of this snippet, or alternatively * provide a unique name for a snippet of code associated with the * generated menu. Save this name in an array g_snippets. * FUNCTION gensnippname g_nsnippets = g_nsnippets + 1 g_snippets[g_nsnippets,1] = getcname(PROCEDURE) g_snippets[g_nsnippets,2] = RECNO() IF MOD(g_nsnippets,25) = 0 DIMENSION g_snippets [g_nsnippets+25,2] ENDIF * * GENPROCCALL - Generate a call statement to snippet procedure. * * Description: * Generate a call to the snippet procedure in the menu definition * code. * FUNCTION genproccall PRIVATE m.trimname, m.basename, m.proc IF singleline() m.proc = PROCEDURE \\ <> ELSE DO gensnippname m.trimname = SYS(2014,UPPER(m.g_outfile),UPPER(m.g_homedir)) m.trimname = stripext(m.trimname) m.basename = basename(m.trimname) \\ ; \ DO <> ; \ IN LOCFILE("<>" \\ ,"MPX;MPR|FXP;PRG" \\ ," *- Localization support [Rev: 2][MOD] \\c_ui_whereis_LOC \\ <>?") ENDIF * * SINGLELINE - Determine if Memo contains only one line. * * Description: * This procedure is used to decide if an ON SELECTION... statement * and a snippet procedure will be needed (i.e., if more than one * line of snippet code then its a snippet, otherwise its a command) * FUNCTION singleline PRIVATE m.size, m.i m.size = MEMLINES(PROCEDURE) IF m.size = 1 RETURN .T. ENDIF m.i = m.size DO WHILE m.i > 1 m.line = MLINE(PROCEDURE, m.i) IF NOT EMPTY(m.line) RETURN .F. ENDIF m.i = m.i - 1 ENDDO * * GENPROCEDURES - Generate procedure/snippet code. * * Description: * Generate 'PROCEDURE procedurename' statement and its body. * FUNCTION genprocedures PRIVATE m.i IF m.g_graphic SET MESSAGE TO c_msg_genprocs_LOC && Localization support [Rev: 2][MOD] ENDIF FOR m.i = 1 TO m.g_nsnippets GOTO RECORD (g_snippets[m.i,2]) DO genfuncheader WITH g_snippets[m.i,1] \PROCEDURE <> DO writecode WITH PROCEDURE \ ENDFOR * * WRITECODE - Write contents of a memo to a low level file. * * Description: * Receive a memo field as a parameter and write its contents out * to the currently opened low level file whose handle is stored * in the system memory variable _TEXT. Contents of the system * memory variable _pretext will affect the positioning of the * generated text. * FUNCTION writecode PARAMETER m.memo, m.codefield PRIVATE m.lines, m.i, m.thisline, m.lHadActPopup IF TYPE("m.codefield") # "C" m.codefield = "" ENDIF m.lHadActPopup = .F. m.lines = MEMLINES(m.memo) _MLINE = 0 FOR m.i = 1 TO m.lines m.thisline = MLINE(m.memo, 1, _MLINE) DO CASE CASE m.g_shortcut AND m.codefield=="cleanup" AND !m.lHadActPopup AND LEFT(UPPER(LTRIM(m.thisline)),5) == "#PREP" && #PREPOPUP in Cleanup DO actpopup m.lHadActPopup = .T. m.g_prepopup = .F. CASE m.g_shortcut AND m.codefield#"cleanup" AND LEFT(UPPER(LTRIM(m.thisline)),5) == "#PREP" && #PREPOPUP in Setup m.g_prepopup = .T. CASE LEFT(UPPER(LTRIM(m.thisline)),5) == "#INSE" && #INSERT DO GenInsertCode WITH m.thisline CASE LEFT(UPPER(LTRIM(m.thisline)),6) == "#IMAGE" && #IMAGEPATHS m.g_imagepaths=.T. CASE INLIST(LEFT(UPPER(LTRIM(m.thisline)),5) ,"#NAME","#PREP") &&skip #PREP for non Shortcut menus * Do nothing OTHERWISE \<> ENDCASE ENDFOR * * GENSETUPCLEANUP - Generate setup/cleanup code. * FUNCTION GenSetupCleanup PARAMETER m.choice LOCATE FOR objtype = IIF(m.g_shortcut,c_shortcut,IIF(m.g_inform,c_sdimenu,c_menu)) DO CASE CASE m.choice == "setup" IF m.g_inform DO sdiheader ENDIF IF EMPTY(setup) RETURN ENDIF IF m.g_graphic SET MESSAGE TO c_msg_gensetup_LOC && Localization support [Rev: 2][MOD] ENDIF DO commentblock WITH m.choice DO writecode WITH setup CASE m.choice == "cleanup" IF !m.g_prepopup AND ATC("#PREP",cleanup)=0 DO actpopup ENDIF IF !EMPTY(cleanup) IF m.g_graphic SET MESSAGE TO c_msg_gencleanup_LOC && Localization support [Rev: 2][MOD] ENDIF DO commentblock WITH m.choice DO writecode WITH cleanup,m.choice ENDIF IF m.g_prepopup DO actpopup ENDIF ENDCASE * * GENINSERTCODE - Emit code from the #insert file, if any * FUNCTION GenInsertCode PARAMETER strg PRIVATE m.word1, m.filname, m.ins_fp, m.buffer IF UPPER(LEFT(LTRIM(m.strg),5)) == "#INSE" m.word1 = wordnum(m.strg,1) m.filname = SUBSTR(m.strg,LEN(m.word1)+1) m.filname = ALLTRIM(CHRTRAN(m.filname,CHR(9),"")) * Bail out if we can't find the file either explicitly or on the DOS path IF !FILE(m.filname) filname = FULLPATH(m.filname,1) IF !FILE(m.filname) \*Insert file <> could not be found RETURN ENDIF ENDIF ins_fp = FOPEN(m.filname) IF ins_fp > 0 \* Inserted from <> DO WHILE !FEOF(ins_fp) m.buffer = FGETS(ins_fp) \<> ENDDO =FCLOSE(m.ins_fp) \* End of inserted lines ENDIF ENDIF ****************************************************************************** * * Code assocated with thermometer. * ****************************************************************************** * * ACTTHERM() - Activate thermometer. * * Description: * Activates thermometer. Update the thermometer with UPDTHERM(). * Thermometer window is named "thermometer." Be sure to RELEASE * this window when done with thermometer. Creates the global * m.g_thermwidth. * FUNCTION acttherm PARAMETER m.text PRIVATE m.prompt IF m.g_graphic m.prompt = m.g_outfile m.prompt = thermfname(m.prompt) DO CASE CASE _WINDOWS LOCAL cWinColor cWinColor = rgbscheme(1, 2) DEFINE WINDOW thermomete ; AT INT((SROW() - (( 5.615 * ; FONTMETRIC(1, m.g_dlgface, m.g_dlgsize, m.g_dlgstyle )) / ; FONTMETRIC(1, WFONT(1,""), WFONT( 2,""), WFONT(3,"")))) / 2), ; INT((SCOL() - (( 63.833 * ; FONTMETRIC(6, m.g_dlgface, m.g_dlgsize, m.g_dlgstyle )) / ; FONTMETRIC(6, WFONT(1,""), WFONT( 2,""), WFONT(3,"")))) / 2) ; SIZE 5.615,63.833 ; FONT m.g_dlgface, m.g_dlgsize ; STYLE m.g_dlgstyle ; NOFLOAT ; NOCLOSE ; NONE ; COLOR &cWinColor MOVE WINDOW thermomete CENTER ACTIVATE WINDOW thermomete NOSHOW @ 0.5,3 SAY m.text FONT m.g_dlgface, m.g_dlgsize STYLE m.g_dlgstyle @ 1.5,3 SAY m.prompt FONT m.g_dlgface, m.g_dlgsize STYLE m.g_dlgstyle @ 0.000,0.000 TO 0.000,63.833 ; COLOR RGB(255, 255, 255, 255, 255, 255) @ 0.000,0.000 TO 5.615,0.000 ; COLOR RGB(255, 255, 255, 255, 255, 255) @ 0.385,0.667 TO 5.231,0.667 ; COLOR RGB(128, 128, 128, 128, 128, 128) @ 0.308,0.667 TO 0.308,63.167 ; COLOR RGB(128, 128, 128, 128, 128, 128) @ 0.385,63.000 TO 5.308,63.000 ; COLOR RGB(255, 255, 255, 255, 255, 255) @ 5.231,0.667 TO 5.231,63.167 ; COLOR RGB(255, 255, 255, 255, 255, 255) @ 5.538,0.000 TO 5.538,63.833 ; COLOR RGB(128, 128, 128, 128, 128, 128) @ 0.000,63.667 TO 5.615,63.667 ; COLOR RGB(128, 128, 128, 128, 128, 128) @ 3.000,3.333 TO 4.231,3.333 ; COLOR RGB(128, 128, 128, 128, 128, 128) @ 3.000,60.333 TO 4.308,60.333 ; COLOR RGB(255, 255, 255, 255, 255, 255) @ 3.000,3.333 TO 3.000,60.333 ; COLOR RGB(128, 128, 128, 128, 128, 128) @ 4.231,3.333 TO 4.231,60.333 ; COLOR RGB(255, 255, 255, 255, 255, 255) m.g_thermwidth = 56.269 CASE _MAC DEFINE WINDOW thermomete ; AT INT((SROW() - (( 5.62 * ; FONTMETRIC(1, m.g_dlgface, m.g_dlgsize, m.g_dlgstyle )) / ; FONTMETRIC(1, WFONT(1,""), WFONT( 2,""), WFONT(3,"")))) / 2), ; INT((SCOL() - (( 63.83 * ; FONTMETRIC(6, m.g_dlgface, m.g_dlgsize, m.g_dlgstyle )) / ; FONTMETRIC(6, WFONT(1,""), WFONT( 2,""), WFONT(3,"")))) / 2) ; SIZE 5.62,63.83 ; FONT m.g_dlgface, m.g_dlgsize ; STYLE m.g_dlgstyle ; NOFLOAT ; NOCLOSE ; NONE ; COLOR RGB(0, 0, 0, 192, 192, 192) MOVE WINDOW thermomete CENTER ACTIVATE WINDOW thermomete NOSHOW @ 0.000,0.000 TO 5.62,63.83 PATTERN 1; COLOR RGB(192, 192, 192, 192, 192, 192) IF ISCOLOR() @ 0.000,0.000 TO 5.62,63.83 PATTERN 1; COLOR RGB(192, 192, 192, 192, 192, 192) @ 0.000,0.000 TO 0.000,63.83 ; COLOR RGB(255, 255, 255, 255, 255, 255) @ 0.000,0.000 TO 5.62,0.000 ; COLOR RGB(255, 255, 255, 255, 255, 255) @ 0.385,0.67 TO 5.23,0.67 ; COLOR RGB(128, 128, 128, 128, 128, 128) @ 0.31,0.67 TO 0.31,63.17 ; COLOR RGB(128, 128, 128, 128, 128, 128) @ 0.385,63.000 TO 5.31,63.000 ; COLOR RGB(255, 255, 255, 255, 255, 255) @ 5.23,0.67 TO 5.23,63.17 ; COLOR RGB(255, 255, 255, 255, 255, 255) @ 5.54,0.000 TO 5.54,63.83 ; COLOR RGB(128, 128, 128, 128, 128, 128) @ 0.000,63.67 TO 5.62,63.67 ; COLOR RGB(128, 128, 128, 128, 128, 128) @ 3.000,3.33 TO 4.23,3.33 ; COLOR RGB(128, 128, 128, 128, 128, 128) @ 3.000,60.33 TO 4.31,60.33 ; COLOR RGB(255, 255, 255, 255, 255, 255) @ 3.000,3.33 TO 3.000,60.33 ; COLOR RGB(128, 128, 128, 128, 128, 128) @ 4.23,3.33 TO 4.23,60.33 ; COLOR RGB(255, 255, 255, 255, 255, 255) ELSE @ 0.000, 0.000 TO 5.62, 63.830 PEN 2 @ 0.230, 0.500 TO 5.39, 63.333 PEN 1 ENDIF @ 0.5,3 SAY m.text FONT m.g_dlgface, m.g_dlgsize STYLE m.g_dlgstyle+"T" ; COLOR RGB(0,0,0,192,192,192) @ 1.5,3 SAY m.prompt FONT m.g_dlgface, m.g_dlgsize STYLE m.g_dlgstyle+"T" ; COLOR RGB(0,0,0,192,192,192) m.g_thermwidth = 56.27 IF !ISCOLOR() @ 3.000,3.33 TO 4.23, (m.g_thermwidth + 1) + 3.33 ENDIF ENDCASE SHOW WINDOW thermomete TOP ELSE m.prompt = SUBSTR(SYS(2014,UPPER(m.g_outfile)),1,48)+; IIF(LEN(m.g_outfile)>48,"...","") DEFINE WINDOW thermomete; FROM INT((SROW()-6)/2), INT((SCOL()-57)/2) ; TO INT((SROW()-6)/2) + 6, INT((SCOL()-57)/2) + 57; DOUBLE COLOR SCHEME 5 ACTIVATE WINDOW thermomete NOSHOW m.g_thermwidth = 50 @ 0,3 SAY m.text @ 1,3 SAY UPPER(m.prompt) @ 2,1 TO 4,m.g_thermwidth+4 &g_boxstrg SHOW WINDOW thermomete TOP ENDIF RETURN * * UPDTHERM() - Update thermometer. * FUNCTION updtherm PARAMETER m.percent PRIVATE m.nblocks, m.percent ACTIVATE WINDOW thermomete m.nblocks = (m.percent/100) * (m.g_thermwidth) DO CASE CASE _WINDOWS @ 3.000,3.333 TO 4.231,m.nblocks + 3.333 ; PATTERN 1 COLOR RGB(128, 128, 128, 128, 128, 128) CASE _MAC @ 3.000,3.33 TO 4.23,m.nblocks + 3.33 ; PATTERN 1 COLOR RGB(0, 0, 128, 0, 0, 128) OTHERWISE @ 3,3 SAY REPLICATE("Û",m.nblocks) ENDCASE * * DEACTTHERMO - Deactivate and Release thermometer window. * FUNCTION deactthermo RELEASE WINDOW thermomete * * Function: THERMFNAME * * [Rev: 8] * Modified to use CutFileLoc() if name is too long. * Moved global variables to top of program. * Merged thermometer window font info with dialogs. FUNCTION thermfname PARAMETER m.fname IF TXTWIDTH(m.fname,m.g_dlgface,m.g_dlgsize,m.g_dlgstyle) > c_space m.fname = CutFileLoc(m.fname, c_space -1) ENDIF RETURN PROPER(m.fname) ****************************************************************************** * * Error Handling Code. * ****************************************************************************** * * ERRORHANDLER - Error Processing Center. * FUNCTION errorhandler PARAMETERS m.messg, m.lineno, m.code IF ERROR() = 22 && Too many memory variables =MESSAGEBOX(c_err_toomanymemvars_LOC + REPL(c_CRLF,2) + c_msg_genstopped_LOC) && Tell the user [Rev: 6][ADD] ON ERROR &onerror DO cleanup CANCEL && Early exit ENDIF DO CASE CASE c_DEBUG && Add debug mode [Rev: 4][BEG] =MESSAGEBOX(m.messg) SET DEBUG ON SET STEP ON * Add debug mode [Rev: 4][END] CASE m.code == c_error_1 && Minor DO errlog WITH m.messg, m.lineno DO errshow WITH m.messg, m.lineno, c_error_1Icon && Show minor errors [Rev: 6][ADD] m.g_status = 1 CASE m.code == c_error_2 && Serious DO errlog WITH m.messg, m.lineno DO errshow WITH m.messg, m.lineno, c_error_2Icon && Pass Error Icon [Rev: 6][ADD] m.g_error = .T. m.g_status = 2 ON ERROR CASE m.code == c_error_3 && Fatal IF NOT m.g_nohandle DO errlog WITH m.messg, m.lineno ENDIF WAIT WINDOW c_msg_genstopped_LOC NOWAIT && Tell the user they are done. [Rev: 6][ADD] DO errshow WITH m.messg, m.lineno, c_error_3Icon && Pass Error Icon [Rev: 6][ADD] WAIT CLEAR IF WEXIST("Thermomete") AND WVISIBLE("Thermomete") RELEASE WINDOW thermomete ENDIF ON ERROR DO cleanup CANCEL && Early exit ENDCASE RETURN * * ESCHANDLER - Escape handler. * FUNCTION eschandler ON ERROR WAIT WINDOW c_msg_genstopped_LOC NOWAIT && Localization support [Rev: 2][MOD] DO builddisable IF m.g_status > 0 ERASE (m.g_outfile) ENDIF IF WEXIST("Thermomete") AND WVISIBLE("Thermomete") RELEASE WINDOW thermomete ENDIF DO cleanup CANCEL && Early exit * * ERRLOG - Insert error message into the error log. * FUNCTION errlog PARAMETER m.messg, m.lineno PRIVATE m.savehandle m.savehandle = _TEXT DO openerrfile SET CONSOLE OFF \\GENERATOR: <> IF NOT EMPTY(m.lineno) \\ LINE NUMBER: <> ENDIF \ = FCLOSE(_TEXT) _TEXT = m.savehandle RETURN * * ERRSHOW - Display error message in the alert box. * FUNCTION errshow PARAMETER m.msg, m.lineno, m.msgicon PRIVATE m.curcursor * Modify to utilize native MESSAGEBOX() function. [Rev: 6][BEG] IF m.g_graphic m.msg = m.msg + REPL(c_CRLF,2) + ; c_err_lineno_LOC + STR(m.lineno, 4) =MESSAGEBOX(m.msg, m.msgicon, c_err_title_LOC) ELSE DEFINE WINDOW alert; FROM INT((SROW()-6)/2), INT((SCOL()-50)/2) TO INT((SROW()-6)/2) + 6, INT((SCOL()-50)/2) + 50 ; FLOAT NOGROW NOCLOSE NOZOOM SHADOW DOUBLE; COLOR SCHEME 7 ACTIVATE WINDOW alert @ 0,0 CLEAR @ 1,0 SAY PADC(SUBSTR(m.msg,1,44)+; IIF(LEN(m.msg)>44,"...",""), WCOLS()) @ 2,0 SAY PADC(c_err_lineno_LOC + STR(m.lineno, 4), WCOLS()) && Localization support [Rev: 2][MOD] @ 3,0 SAY PADC(c_err_presskey_LOC, WCOLS()) && Localization support [Rev: 2][MOD] m.curcursor = SET( "CURSOR" ) SET CURSOR OFF WAIT "" RELEASE WINDOW alert SET CURSOR &curcursor RELEASE WINDOW alert ENDIF * Modify to utilize native MESSAGEBOX() function. [Rev: 6][END] RETURN * * OPENERRFILE - Open error file. * FUNCTION openerrfile PRIVATE m.errfile, m.errhandle m.errfile = m.g_errlog+".ERR" m.errhandle = FOPEN(m.errfile,2) IF m.errhandle < 0 m.errhandle = FCREATE(m.errfile) IF m.errhandle < 0 DO errshow WITH c_err_noopenerr_LOC, LINENO() && Localization support [Rev: 2][MOD] m.g_status = 2 IF WEXIST("Thermomete") AND WVISIBLE("Thermomete") RELEASE WINDOW thermomete ENDIF ON ERROR RETURN TO MASTER ENDIF ELSE = FSEEK(m.errhandle,0,2) ENDIF IF SET("TEXTMERGE") = "OFF" SET TEXTMERGE ON ENDIF _TEXT = m.errhandle * * GETCNAME - Manufacture a procedure name, unless there is a #NAME directive * FUNCTION getcname PARAMETERS snippet PRIVATE ALL IF proctype = 1 numlines = MEMLINES(snippet) IF m.numlines > 0 _MLINE = 0 m.i = 1 DO WHILE m.i <= m.numlines m.thisline = UPPER(ALLTRIM(MLINE(snippet,1, _MLINE))) DO CASE CASE LEFT(m.thisline,5) == "#NAME" RETURN ALLTRIM(SUBSTR(m.thisline,6)) CASE EMPTY(m.thisline) OR iscomment(m.thisline) * Do nothing. Get next line. OTHERWISE EXIT ENDCASE m.i = m.i + 1 ENDDO ENDIF ENDIF RETURN LOWER(SYS(2015)) * * ISCOMMENT - Determine if textline is a comment line. * FUNCTION IsComment PARAMETER m.textline PRIVATE m.asterisk, m.isnote, m.ampersand, m.statement IF EMPTY(m.textline) RETURN .F. ENDIF m.statement = UPPER(ALLTRIM(m.textline)) m.asterisk = AT("*", LEFT(m.statement,1)) m.ampersand = AT(CHR(38)+CHR(38), LEFT(m.statement,2)) m.isnote = AT("NOTE", LEFT(m.statement,4)) DO CASE CASE (m.asterisk = 1 OR m.ampersand = 1) RETURN .T. CASE (m.isnote = 1 ; AND (LEN(m.statement) <= 4 OR SUBSTR(m.statement,5,1) = ' ')) * Don't be fooled by something like "notebook = 7" RETURN .T. ENDCASE RETURN .F. * * WORDNUM - Returns w_num-th word from string strg * FUNCTION wordnum PARAMETERS strg,w_num PRIVATE strg,s1,w_num,ret_str m.s1 = ALLTRIM(m.strg) * Replace tabs with spaces m.s1 = CHRTRAN(m.s1,CHR(9)," ") * Reduce multiple spaces to a single space DO WHILE AT(' ',m.s1) > 0 m.s1 = STRTRAN(m.s1,' ',' ') ENDDO ret_str = "" DO CASE CASE m.w_num > 1 DO CASE CASE AT(" ",m.s1,m.w_num-1) = 0 && No word w_num. Past end of string. m.ret_str = "" CASE AT(" ",m.s1,m.w_num) = 0 && Word w_num is last word in string. m.ret_str = SUBSTR(m.s1,AT(" ",m.s1,m.w_num-1)+1,255) OTHERWISE && Word w_num is in the middle. m.strt_pos = AT(" ",m.s1,m.w_num-1) m.ret_str = SUBSTR(m.s1,strt_pos,AT(" ",m.s1,m.w_num)+1 - strt_pos) ENDCASE CASE m.w_num = 1 IF AT(" ",m.s1) > 0 && Get first word. m.ret_str = SUBSTR(m.s1,1,AT(" ",m.s1)-1) ELSE && There is only one word. Get it. m.ret_str = m.s1 ENDIF ENDCASE RETURN ALLTRIM(m.ret_str) * * VERSNUM - Return string corresponding to FoxPro version number * FUNCTION versnum RETURN STRTRAN(SUBS(VERS(),AT(".",VERS())-2),"0","",1,1) PROCEDURE sdiheader \* To attach this menu to your Top-Level form, \* call it from the Init event of the form: \ \* Syntax: DO WITH [,|][] \ \* oFormRef - form object reference (THIS) \* cMenuname - name for menu (this is required for Append menus - see below) \* lRename - renames Name property of your form \* lUniquePopups - determines whether to generate unique ids for popup names \ \* example: \ \* PROCEDURE Init \* DO mymenu.mpr WITH THIS,.T. \* ENDPROC \ \* Use the optional 2nd parameter if you plan on running multiple instances \* of your Top-Level form. The preferred method is to create an empty string \* variable and pass it by reference so you can receive the form name after \* the MPR file is run. You can later use this reference to destroy the menu. \ \* PROCEDURE Init \* LOCAL cGetMenuName \* cGetMenuName = "" \* DO mymenu.mpr WITH THIS, m.cGetMenuName \* ENDPROC \ \* The logical lRename parameter will change the name property of your \* form to the same name given the menu and may cause conflicts in your \* code if you directly reference the form by name. \ \* You will also need to remove the menu when the form is destroyed so that it does \* not remain in memory unless you wish to reactivate it later in a new form. \ \* If you passed the optional lRename parameter as .T. as in the above example, \* you can easily remove the menu in the form's Destroy event as shown below. \* This strategy is ideal when using multiple instances of Top-Level forms. \ \* example: \ \* PROCEDURE Destroy \* RELEASE MENU (THIS.Name) EXTENDED \* ENDPROC \ \* Using Append/Before/After location options: \ \* You might want to append a menu to an existing Top-Level form by setting \* the Location option in the General Options dialog. In order to do this, you \* must pass the name of the menu in which to attach the new one. The second \* parameter is required here. If you originally created the menu with the lRename \* parameter = .T., then you can update the menu with code similar to the following: \ \* example: \ \* DO mymenu2.mpr WITH THISFORM,THISFORM.name \* \* Using lUniquePopups: \ \* If you are running this menu multiple times in your application, such as in multiple \* instances of the same top-level form, you should pass .T. to the lUniquePopups \* parameter so that unique popup names are generated to avoid possible conflicts. \ \* example: \ \* PROCEDURE Init \* DO mymenu.mpr WITH THIS,.T.,.T. \* ENDPROC \* \* Note: Parm4-Parm9 are not reserved and freely available for use with your menu code. \* \ \LPARAMETERS oFormRef, getMenuName, lUniquePopups, parm4, parm5, parm6, parm7, parm8, parm9 \LOCAL cMenuName, nTotPops, a_menupops, cTypeParm2, cSaveFormName \IF TYPE("m.oFormRef") # "O" OR ; \ LOWER(m.oFormRef.BaseClass) # 'form' OR ; \ m.oFormRef.ShowWindow # 2 \ MESSAGEBOX(<>) \ RETURN \ENDIF \m.cTypeParm2 = TYPE("m.getMenuName") \m.cMenuName = SYS(2015) \m.cSaveFormName = m.oFormRef.Name *!* \DO CASE *!* \CASE m.cTypeParm2 = "C" AND !EMPTY(m.getMenuName) *!* \ m.cMenuName = m.getMenuName *!* \CASE m.cTypeParm2 = "C" OR (m.cTypeParm2 = "L" AND m.getMenuName) *!* \ m.oFormRef.Name = m.cMenuName *!* \ENDCASE \IF m.cTypeParm2 = "C" OR (m.cTypeParm2 = "L" AND m.getMenuName) \ m.oFormRef.Name = m.cMenuName \ENDIF \IF m.cTypeParm2 = "C" AND !EMPTY(m.getMenuName) \ m.cMenuName = m.getMenuName \ENDIF LOCAL ntotpops,cPopRef ,i SELECT PADR(LOWER(name),25) FROM (DBF()); WHERE numitems#0 AND objtype =2 AND ATC("_MSYSMENU",levelname)=0; INTO ARRAY g_aPops m.ntotpops=_TALLY IF m.ntotpops>0 DIMENSION g_aPops[m.ntotpops] \DIMENSION a_menupops[<>] \IF TYPE("m.lUniquePopups")="L" AND m.lUniquePopups \ FOR nTotPops = 1 TO ALEN(a_menupops) \ a_menupops[m.nTotPops]= SYS(2015) \ ENDFOR \ELSE FOR i = 1 TO ALEN(g_aPops) g_aPops[m.i] = ALLTRIM(g_aPops[m.i]) \ a_menupops[<>]="<>" ENDFOR \ENDIF \ ENDIF ENDFUNC * GetMenuType * Description: Determines which type of menu we have. * Parameters: * Return value: * PROCEDURE GetMenuType * Determine if we have a shortcut menu LOCATE FOR objtype = c_shortcut IF FOUND() m.g_shortcut = .T. RETURN ENDIF * Determine if we have SDI menu LOCATE FOR objtype = c_sdimenu IF FOUND() m.g_inform = .T. ENDIF RETURN * actpopup * Description: writes out code to * activate popup if we have shortcut menu * Parameters: * Return value: * PROCEDURE actpopup DO CASE CASE m.g_shortcut \ACTIVATE POPUP <> CASE m.g_inform AND m.g_location = c_replace \ACTIVATE MENU (m.cMenuName) NOWAIT CASE m.g_inform \ACTIVATE MENU (m.cMenuName) NOWAIT ENDCASE IF m.g_inform \ \IF m.cTypeParm2 = "C" \ m.getMenuName = m.cMenuName \ m.oFormRef.Name = m.cSaveFormName \ENDIF \ ENDIF RETURN ****************************************************************************** * * File and Path functions * ****************************************************************************** * * CUTFILELOC - Return a chopped file and path * * FUNCTION cutfileloc LPARAMETERS cFile, nLength LOCAL cString, cTempPath, cTempFile, nPlen, nFlen IF LEN(m.cFile) > m.nLength * Get everything uppercase cFile = UPPER(m.cFile) * Get the filename and length cTempFile = justfname(m.cFile) nFlen = LEN(m.cTempFile) * Find the minimum path length (could be "c:\") cTempPath = cutfpath(STRTRAN(m.cFile,m.cTempFile,"",1),8) nPlen = LEN(m.cTempPath) * If the filename + the min path is longer than nLength, cut the file name. IF m.nFlen + m.nPlen > m.nLength cString = m.cTempPath + cutfname(m.cFile,m.nLength-m.nPlen) ELSE cTempPath = STRTRAN(m.cFile,m.cTempfile,"",1) cString = cutfpath(m.cTempPath,(m.nLength-m.nFlen)) + m.cTempfile ENDIF ELSE cString = m.cFile ENDIF RETURN m.cString * * Function: PARTIALFNAME * FUNCTION partialfname PARAMETER m.filname, m.fillen * Return a filname no longer than m.fillen characters. Take some chars * out of the middle if necessary. No matter what m.fillen is, this function * always returns at least the file stem and extension. PRIVATE m.bname, m.elipse, m.remain m.elipse = "..." + m.g_pathsep IF _MAC m.bname = SUBSTR(m.filname, RAT(":",m.filname)+1) ELSE m.bname = justfname(m.filname) ENDIF DO CASE CASE LEN(m.filname) <= m.fillen m.retstr = m.filname CASE LEN(m.bname) + LEN(m.elipse) >= m.fillen m.retstr = m.bname OTHERWISE m.remain = MAX(m.fillen - LEN(m.bname) - LEN(m.elipse), 0) IF _MAC m.retstr = LEFT(SUBSTR(m.filname,1,RAT(":",m.filname)-1),m.remain) ; +m.elipse+m.bname ELSE m.retstr = LEFT(justpath(m.filname),m.remain)+m.elipse+m.bname ENDIF ENDCASE RETURN m.retstr * * CUTFNAME - Return a chopped filename * * ie: "REALLYLONGFILENAME.TXT" = "REALLYLONG..." FUNCTION cutfname LPARAMETERS cFilename, nLength cFilename = ALLTRIM(m.cFilename) IF RAT(m.g_pathsep,m.cFilename) > 0 m.cFilename = SUBSTR(m.cFilename,RAT(m.g_pathsep,m.cFilename)+1) ENDIF IF LEN(m.cFilename) > m.nLength m.cFilename = LEFT(m.cFilename,m.nLength-4) + "..." ENDIF RETURN m.cFilename * * CUTFPATH - Return a chopped filepath * * ie: "C:\REALLYLONGPATH\SUB\ETC\" = "C:\ ...\SUB\ETC\" FUNCTION cutfpath LPARAMETERS cFilepath, nLength LOCAL cPre, cString, nRemain, nOccurs IF _MAC OR LEN(m.cFilepath) > m.nLength cFilePath = SYS(2027, m.cFilePath) && Remove relative paths ENDIF IF LEN(m.cFilepath) > m.nLength cPre = LEFT(m.cFilePath,AT(m.g_pathsep,m.cFilePath)) + "... " + m.g_pathsep nRemain = nLength - LEN(m.cPre) cString = RIGHT(cFilepath,m.nRemain) IF OCCURS(m.g_pathsep,m.cString)>1 cString = m.cPre + SUBS(cString,AT(m.g_pathsep,m.cString)) ELSE cString = m.cPre && last directory on path is too long ENDIF ELSE cString = m.cFilepath ENDIF RETURN m.cString * * JUSTFNAME - Return just a filename * FUNCTION justfname PARAMETERS m.filname PRIVATE ALL IF RAT('\',m.filname) > 0 m.filname = SUBSTR(m.filname,RAT('\',m.filname)+1,255) ENDIF IF AT(':',m.filname) > 0 m.filname = SUBSTR(m.filname,AT(':',m.filname)+1,255) ENDIF RETURN ALLTRIM(UPPER(m.filname)) * * JUSTPATH - Return just the path name from "filname" * FUNCTION justpath PARAMETERS m.filname PRIVATE ALL m.filname = ALLTRIM(UPPER(m.filname)) IF '\' $ m.filname m.filname = SUBSTR(m.filname,1,RAT('\',m.filname)) IF RIGHT(m.filname,1) = '\' AND LEN(m.filname) > 1 ; AND SUBSTR(m.filname,LEN(m.filname)-1,1) <> ':' filname = SUBSTR(m.filname,1,LEN(m.filname)-1) ENDIF RETURN m.filname ELSE RETURN '' ENDIF * * STRIPEXT - Strip the extension from a file name. * * Description: * Use the algorithm employed by FoxPRO itself to strip a * file of an extension (if any): Find the rightmost dot in * the filename. If this dot occurs to the right of a "\" * or ":", then treat everything from the dot rightward * as an extension. Of course, if we found no dot, * we just hand back the filename unchanged. * * Parameters: * filename - character string representing a file name * * Return value: * The string "filename" with any extension removed * FUNCTION stripext PARAMETER m.filename PRIVATE m.dotpos, m.terminator m.dotpos = RAT(".", m.filename) m.terminator = MAX(RAT("\", m.filename), RAT(":", m.filename)) IF m.dotpos > m.terminator m.filename = LEFT(m.filename, m.dotpos-1) ENDIF RETURN m.filename * * STRIPPATH - Strip the path from a file name. * * Description: * Find positions of backslash in the name of the file. If there is one * take everything to the right of its position and make it the new file * name. If there is no slash look for colon. Again if found, take * everything to the right of it as the new name. If neither slash * nor colon are found then return the name unchanged. * * Parameters: * filename - character string representing a file name * * Return value: * The string "filename" with any path removed * FUNCTION strippath PARAMETER m.filename PRIVATE m.slashpos, m.namelen, m.colonpos m.slashpos = RAT("\", m.filename) IF m.slashpos > 0 m.namelen = LEN(m.filename) - m.slashpos m.filename = RIGHT(m.filename, m.namelen) ELSE m.colonpos = RAT(":", m.filename) IF m.colonpos > 0 m.namelen = LEN(m.filename) - m.colonpos m.filename = RIGHT(m.filename, m.namelen) ENDIF ENDIF RETURN m.filename * BASENAME - returns strippath(stripext(filespec)) * FUNCTION basename PARAMETER m.filespec RETURN strippath(stripext(m.filespec)) ****************************************************************************** * Revisions History * $History: GENMENU.PRG $ * * ***************** Version 15 ***************** * User: rb Date: 10/04/01 * Updated in $/Genmenu * * Improved SKIP FOR .F. handling * ***************** Version 14 ***************** * User: rb Date: 11/07/00 * Updated in $/Genmenu * * Added code to skip obsolete menu bars: * Spell Checker, RunActiveDoc, Setup Wizard * * New #IMAGEPATHS directive (place in Setup snippet) * to generate fullpaths for images. * * ***************** Version 13 ***************** * User: rb Date: 09/01/00 * Updated in $/Genmenu * * We now avoid emitting SKIP FOR .F. and just emit * content after .F. * * ***************** Version 12 ***************** * User: rb Date: 07/01/99 Time: 1:04 * Updated in $/Genmenu * * Added support for new DEFINE BAR ... PICTURE/PICTRES * * ***************** Version 11 ***************** * User: rb Date: 11/30/96 Time: 1:04a * Updated in $/Genmenu * Enhanced #PREPOP for Cleanup snippet placeholder * Changed naming convention of menu popups in Top-Level * form menus to avoid conflicts with RELEASE MENU... * extended. * Fixed Top-Level Form - append menu problem. * Fixed Setup/Cleanup code not gen for Top-Level Form. * ***************** Version 10 ***************** * User: rb Date: 5/1/96 Time: 1:04a * Updated in $/Genmenu * Added #PREPOPUP generator directive to control whether * Cleanup code is placed before/after ACTIVATE POPUP * line for Shortcut menus. * ***************** Version 9 ***************** * User: rb Date: 3/8/96 Time: 1:04a * Updated in $/Genmenu * Added support for new shortcut popup and SDI form menus * - actpopup() new proc to add shortcut activate code * - GetMenuType() new proc to determine menu type (shortcut, SDI, etc.) * - defbars () added new parameter to safeguard shortcut popup name * - defonbar () added new parameter to safeguard shortcut popup name * ***************** Version 8 ***************** * User: Dta Date: 3/19/95 Time: 1:04a * Updated in $/Genmenu * - Thermfname() modified to use new function CutFileLoc(). * - CutFileLoc(), CutFPath() and CutFName() written to handle * formating for long file, path and directory names. * - Grouped similiar functions. * - Fixed release thermometer window bug. * - Merge dialog and thermometer fonts. * - Moved g_pathsep to globals definition area. * * ***************** Version 7 ***************** * User: Dta Date: 3/18/95 Time: 7:36p * Updated in $/Genmenu * - Change c_aliaslen to 255 to support long file names. * - Add support for intelligent Pad hotkeys * * ***************** Version 6 ***************** * User: Dta Date: 3/18/95 Time: 5:19p * Updated in $/Genmenu * - Add support for no "!" in menu file name. * - Modify error routine to utilize MESSAGEBOX() * * ***************** Version 5 ***************** * User: Dta Date: 1/11/95 Time: 9:45a * Updated in $/Genmenu * - Beautified and documentation changes * - Branched for Localization * * ***************** Version 4 ***************** * User: Dta Date: 1/10/95 Time: 6:36p * Updated in $/Genmenu * - Add support for DEBUG mode * - Add message for ERROR 22 * - #DEFINEs moved above executable code * - Dialog Fonts changed for localization * * ***************** Version 3 ***************** * User: Dta Date: 1/10/95 Time: 5:56p * Updated in $/Genmenu * - Change localization constants to support naming convention. * * ***************** Version 2 ***************** * User: Dta Date: 12/10/94 Time: 8:20a * Updated in $/Genmenu * - Change PJXFields constant to 3.0 value. * - Add AGAIN to USE command when opening project. * - Add constants for Localization support. * - Remove "arranged" from NOCPTRANS command. * - Modify VERSNUM() to support 3.0 VERS() convention. * - Add version control documentation. * * ***************** Version 1 ***************** * User: Dta Date: 12/1/95 Time: 3:13p * Added in $/Genmenu * - Orignial 2.6a GENMENU shipping version. * *